home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turnbull China Bikeride
/
Turnbull China Bikeride - Disc 2.iso
/
STUTTGART
/
LANG
/
LISP
/
FOOLS
/
!Fl
/
scm
/
extra
< prev
next >
Wrap
Text File
|
1994-11-19
|
9KB
|
291 lines
;;; extra functions and macros
(define (list-ref l k)
;; kth element of l
(and (pair? l) (if (<= k 0) (car l) (list-ref (cdr l) (- k 1)))))
(define (list-tail l k)
;; sublist of l omitting the first k elements
(and (pair? l) (if (<= k 0) l (list-tail (cdr l) (- k 1)))))
(define (last-pair l)
;; the last pair of the list
(if (pair? (cdr l)) (last-pair (cdr l)) l))
(define (append! a b)
(if (null? a) b (begin (set-cdr! (last-pair a) b) a)))
;; ASCII based character predicates
(define (char-upper-case? c) (and (char>=? c #\A) (char<=? c #\Z)))
(define (char-lower-case? c) (and (char>=? c #\a) (char<=? c #\z)))
(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
(define (char-numeric? c) (and (char>=? c #\0) (char <=? c #\9)))
(define (char-whitespace? c) (memv c '(#\space #\tab #\newline)))
(define (char-upcase c) (if (char-lower-case? c) (integer->char (- c 32)) c))
(define (char-downcase c) (if (char-upper-case? c) (integer->char (+ c 32)) c))
(define gensym
;; generate unique symbols
(let ((counter 0))
(lambda () (begin1
(string->uninterned-symbol
(string-append "G" (integer->string counter #\d)))
(set! counter (+ counter 1))))))
(define-macro (while pred . body)
;; while pred is true, evaluate the expressions in body and return the
;; result of the last expression evaluated (or #f if none were evaluated)
(let ((while-loop (gensym))
(while-res (gensym)))
`(letrec ((,while-loop
(lambda (,while-res)
(if ,pred (,while-loop (begin ,@body)) ,while-res))))
(,while-loop #f))))
(define-macro (when pred . body)
;; evaluate body if pred is true
`(and ,pred (begin ,@body)))
(define-macro (unless pred . body)
;; evaluate body if pred is false
`(or ,pred (begin ,@body)))
(define-macro (case key . clauses)
;; conditionally execute the clause eqv? to key
(define (case-make-clauses key)
`(cond ,@(map
(lambda (clause)
(if (pair? clause)
(let ((case (car clause))
(exprs (cdr clause)))
(cond ((eq? case 'else)
`(else ,@exprs))
((pair? case)
(if (= (length case) 1)
`((eqv? ,key ',(car case)) ,@exprs)
`((memv ,key ',case) ,@exprs)))
(else
`((eqv? ,key ',case) ,@exprs))))
(error 'case "invalid syntax in ~a" clause)))
clauses)))
(if (pair? key)
(let ((newkey (gensym)))
`(let ((,newkey ,key))
,(case-make-clauses newkey)))
(case-make-clauses key)))
(define-macro (let* bindings . body)
;; sequentially perform the bindings then evaluate the expressions in body
;; within the new scope defined by the bindings
(if (null? bindings)
`(let () ,@body)
`(let ((,(caar bindings) ,(cadar bindings)))
(let* ,(cdr bindings) ,@body))))
(define-macro (let bindings . body)
;; extend let to handle (let name bindings expr ...)
(if (symbol? bindings)
;; named let
`(letrec ((,bindings
(lambda ,(map car (car body)) ,@(cdr body))))
(,bindings ,@(map cadr (car body))))
`((lambda ,(map car bindings) ,@body) ,@(map cadr bindings))))
(define list-join
;; pair-wise join the lists in lsts (the output is in reverse order)
(letrec ((join-iter
(lambda (lsts out)
(if (ormap null? lsts)
out
(join-iter (map cdr lsts) (cons (map car lsts) out))))))
(lambda (lsts) (join-iter lsts '()))))
(define map
;; redefine map to handle multiple argument lists
(letrec ((map-loop
(lambda (fcn lst out)
(if (null? lst)
out
(map-loop fcn (cdr lst) (cons (fcn (car lst)) out))))))
(lambda (fcn lst . rest)
(if (null? rest)
(reverse (map-loop fcn lst '()))
(map-loop (lambda (x) (apply fcn x))
(list-join (cons lst rest))
'())))))
(define for-each
;; redefine for-each to handle multiple argument lists
(letrec ((for-loop
(lambda (fcn lst)
(if (null? lst)
#t
(begin (fcn (car lst)) (for-loop fcn (cdr lst)))))))
(lambda (fcn lst . rest)
(if (null? rest)
(for-loop fcn lst)
(for-loop (lambda (x) (apply fcn x))
(reverse (list-join (cons lst rest))))))))
(define ormap
(letrec ((ormap1
(lambda (pred lst last)
(or last
(and (pair? lst)
(ormap1 pred (cdr lst) (pred (car lst))))))))
(lambda (pred lst . rest)
(if (null? rest)
(ormap1 pred lst #f)
(ormap1 (lambda (x) (apply pred x))
(reverse (list-join (cons lst rest)))
#f)))))
(define andmap
(letrec ((andmap1
(lambda (pred lst last)
(if last
(if (pair? lst)
(andmap1 pred (cdr lst) (pred (car lst)))
last)))))
(lambda (pred lst . rest)
(if (null? rest)
(andmap1 pred lst #t)
(andmap1 (lambda (x) (apply pred x))
(reverse (list-join (cons lst rest)))
#t)))))
(define (string . chars)
;; build a string out of the characters in chars
(list->string chars))
(define duplicates
;; find the duplicates in a list using eq?
(letrec ((dupes
(lambda (l f d)
(if (null? l) d
(let ((elt (car l)))
(if (memq elt f)
(if (memq elt d)
(dupes (cdr l) f d)
(dupes (cdr l) f (cons elt d)))
(dupes (cdr l) (cons elt f) d)))))))
(lambda (l) (dupes l '() '()))))
;; the top-level environment
(define user-initial-environment (package-environment 'top-level))
;;; streams
(define-macro delay
(letrec ([make-promise
(lambda (proc)
(let ((already-run? #f) (result #f))
(lambda ()
(if already-run? result
(begin (set! result (proc))
(set! already-run? #t)
result)))))])
(lambda (expr) `(,make-promise (lambda () ,expr)))))
(define (force expr) (expr))
(define-macro (cons-stream head tail) `(cons ,head (delay ,tail)))
(define head car)
(define (tail stream) (force (cdr stream)))
(define the-empty-stream nil)
(define empty-stream? null?)
(define (nth-stream n s)
(and (pair? s) (if (< n 1) (head s) (nth-stream (- n 1) (tail s)))))
(define (map-stream fcn s)
(if (empty-stream? s) the-empty-stream
(cons-stream (fcn (head s)) (map-stream fcn (tail s)))))
(define (filter-stream pred s)
(cond ((empty-stream? s) the-empty-stream)
((pred (head s)) (cons-stream (head s) (filter-stream pred (tail s))))
(else (filter-stream pred (tail s)))))
;; printf and fprintf
(define (vfprintf file fmt args)
(letrec ((len (string-length fmt))
(get-arg
(lambda ()
(if (null? args)
(error 'vfprintf "missing arguments")
(begin1 (car args) (set! args (cdr args))))))
(process
(lambda (ptr)
(if (< ptr len)
(let ((c (string-ref fmt ptr)))
(cond [(char=? c #\~)
(case (string-ref fmt (+ ptr 1))
[#\s (write (get-arg) file)]
[#\a (display (get-arg) file)]
[#\c (write-char (get-arg) file)]
[#\% (newline file)]
[#\~ (write-char #\~ file)]
[else
(write-char (string-ref fmt (+ ptr 1)) file)])
(process (+ ptr 2))]
[else
(write-char c file)
(process (+ ptr 1))]))
(if (not (null? args))
(error 'vfprintf "supplied extra arguments ~s" args))))))
(process 0)))
(define (fprintf file fmt . args) (vfprintf file fmt args))
(define (printf fmt . args) (vfprintf (current-output-port) fmt args))
(define (error proc fmt . args)
(printf "~%~a: " proc)
(vfprintf (current-output-port) fmt args)
(newline)
(abort))
;;; packages
;; where to look for packages (include a trailing slash)
;; --- ams fiddled.
; (define *package-path* '("./" "~/scm/" "/usr/share/new/lib/fools/"))
(define *package-path* '("<Fools$Path>.scm." "@."))
;; file extension for packages
; --- ams we dont have file extensions ;-)
; (define *package-ext* ".scm")
(define *package-ext* "")
;; packages loaded
(define *packages* '())
;; if true print name of package when loaded
(define *load-verbose* #t)
(define (find-package package)
;; find the file name of package
(define (for-each-path paths)
(if (null? paths) #f
(let ((fname (string-append (car paths) package)))
(if (file-access fname "r") fname
(for-each-path (cdr paths))))))
(for-each-path *package-path*))
(define (require package)
;; load package if not already loaded
(if (memq package *packages*) #t
(let ((filename (find-package (string-append package *package-ext*))))
(if filename
(begin
(when *load-verbose*
(printf "; loading ~s~%" filename))
(load filename))
(error 'require "can't find package ~s in ~s"
package *package-path*)))))
(define (provide package)
;; note somewhere that package is loaded
(if (memq package *packages*)
(error 'provide "package ~s is already loaded" package)
(begin (set! *packages* (cons package *packages*)) #t)))